home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / fools.lzh / init.scm < prev    next >
Text File  |  1990-03-02  |  7KB  |  210 lines
  1. ;;; fools' lisp init file
  2.  
  3. ; c[ad]+r
  4. (define caar (lambda (l) (car (car l))))
  5. (define cdar (lambda (l) (cdr (car l))))
  6. (define cadr (lambda (l) (car (cdr l))))
  7. (define cddr (lambda (l) (cdr (cdr l))))
  8. (define caaar (lambda (l) (car (car (car l)))))
  9. (define cdaar (lambda (l) (cdr (car (car l)))))
  10. (define cadar (lambda (l) (car (cdr (car l)))))
  11. (define cddar (lambda (l) (cdr (cdr (car l)))))
  12. (define caadr (lambda (l) (car (car (cdr l)))))
  13. (define cdadr (lambda (l) (cdr (car (cdr l)))))
  14. (define caddr (lambda (l) (car (cdr (cdr l)))))
  15. (define cdddr (lambda (l) (cdr (cdr (cdr l)))))
  16. (define caaaar (lambda (l) (car (car (car (car l))))))
  17. (define cdaaar (lambda (l) (cdr (car (car (car l))))))
  18. (define cadaar (lambda (l) (car (cdr (car (car l))))))
  19. (define cddaar (lambda (l) (cdr (cdr (car (car l))))))
  20. (define caadar (lambda (l) (car (car (cdr (car l))))))
  21. (define cdadar (lambda (l) (cdr (car (cdr (car l))))))
  22. (define caddar (lambda (l) (car (cdr (cdr (car l))))))
  23. (define cdddar (lambda (l) (cdr (cdr (cdr (car l))))))
  24. (define caaadr (lambda (l) (car (car (car (cdr l))))))
  25. (define cdaadr (lambda (l) (cdr (car (car (cdr l))))))
  26. (define cadadr (lambda (l) (car (cdr (car (cdr l))))))
  27. (define cddadr (lambda (l) (cdr (cdr (car (cdr l))))))
  28. (define caaddr (lambda (l) (car (car (cdr (cdr l))))))
  29. (define cdaddr (lambda (l) (cdr (car (cdr (cdr l))))))
  30. (define cadddr (lambda (l) (car (cdr (cdr (cdr l))))))
  31. (define cddddr (lambda (l) (cdr (cdr (cdr (cdr l))))))
  32.  
  33. (define-macro define
  34.   (lambda (sym . body)
  35.     (if (pair? sym)
  36.     `(define ,(car sym) (lambda ,(cdr sym) ,@body))
  37.     `(define ,sym ,@body))))
  38.  
  39. (define-macro define-macro
  40.   (lambda (macro . body)
  41.     (if (pair? macro)
  42.     `(define-macro ,(car macro) (lambda ,(cdr macro) ,@body))
  43.     `(define-macro ,macro ,@body))))
  44.  
  45. (define (call/cc proc) (call-with-current-continuation proc))
  46.  
  47. (define (reduce fnc lst init)
  48.   ; apply binary fnc to each element in lst
  49.   ; (reduce + '(1 2 3) 0) is equivalent to (+ (+ (+ 0 1) 2) 3)
  50.   (if (null? lst) init (reduce fnc (cdr lst) (fnc init (car lst)))))
  51.  
  52. (define reverse
  53.   ; reverse the top elements of a list (non-destructive)
  54.   ((lambda ()
  55.      (define (reverse-iter lst rev)
  56.        (if (null? lst) rev (reverse-iter (cdr lst) (cons (car lst) rev))))
  57.      (lambda (lst) (reverse-iter lst '())))))
  58.  
  59. (define (map fcn lst)
  60.   (define (map-iter lst out)
  61.     (if (null? lst)
  62.     out
  63.     (map-iter (cdr lst) (cons (fcn (car lst)) out))))
  64.   (reverse (map-iter lst '())))
  65.  
  66. (define (for-each fcn lst)
  67.   (if (null? lst) #t (begin (fcn (car lst)) (for-each fcn (cdr lst)))))
  68.  
  69. (define-macro (let bindings . body)
  70.   ; macro to unsugar (let ((binding val) ... ) expr ... )
  71.   `((lambda ,(map car bindings) ,@body) ,@(map cadr bindings)))
  72.  
  73. (define-macro letrec
  74.   ; macro to unsugar (letrec ((rec-def val) ... ) expr ... )
  75.   ((lambda ()
  76.      (define (letrec-defs def)
  77.        `(define  ,(car def) ,@(cdr def)))
  78.      (lambda (defs . exprs)
  79.        `((lambda () ,@(map letrec-defs defs) ,@exprs))))))
  80.  
  81. (define-macro (cond . clauses)
  82.   (if (null? clauses)
  83.       #f
  84.       (let ((test (caar clauses)) (exprs (cdar clauses)))
  85.     (if (null? exprs)
  86.         (if (eq? test 'else)
  87.         #t
  88.         `(or ,test (cond ,@(cdr clauses))))
  89.         (if (eq? test 'else)
  90.         `(begin ,@exprs)
  91.         (if (and (pair? exprs) (eq? (car exprs) '=>))
  92.             (let ((result (string->uninterned-symbol "result")))
  93.               `(let ((,result ,test))
  94.              (if ,result
  95.                  (,(cadr exprs) ,result)
  96.                  (cond ,@(cdr clauses)))))
  97.             `(if ,test
  98.              (begin ,@exprs)
  99.              (cond ,@(cdr clauses)))))))))
  100.  
  101. (define (atom? x) (not (pair? x)))
  102.  
  103. (define (1- x) (- x 1))
  104. (define (1+ x) (+ x 1))
  105. (define (negative? a) (< a 0))
  106. (define (positive? a) (> a 0))
  107. (define (zero? a) (= a 0))
  108. (define (even? x) (= x (* 2 (floor (/ x 2)))))
  109. (define (odd? x) (not (= x (* 2 (floor (/ x 2))))))
  110. (define (complex? x) #f)
  111. (define (rational? x) #f)
  112. (define real? number?)
  113. (define (sqrt x) (expt x 0.5))
  114. (define (square x) (* x x))
  115.  
  116. (define (nth n l)
  117.   ; nth item in list or #f if l is too short
  118.   (and (pair? l) (if (<= n 0) (car l) (nth (- n 1) (cdr l)))))
  119.  
  120. (define length
  121.   (letrec ((length-iter
  122.         (lambda (lst len)
  123.           (if (null? lst) len (length-iter (cdr lst) (+ len 1))))))
  124.     (lambda (lst) (length-iter lst 0))))
  125.  
  126. (define (list? l)
  127.   ; t if l terminates with a nil in the last cdr (may not return)
  128.   (if (pair? l) (list? (cdr l)) (null? l)))
  129.  
  130. (define (memq item lst)
  131.   (if (null? lst) #f (if (eq? item (car lst)) lst (memq item (cdr lst)))))
  132. (define (memv item lst)
  133.   (if (null? lst) #f (if (eqv? item (car lst)) lst (memv item (cdr lst)))))
  134. (define (member item lst)
  135.   (if (null? lst) () (if (equal? item (car lst)) lst (member item (cdr lst)))))
  136.  
  137. (define (assq item table)
  138.   (if (null? table) #f
  139.       (if (eq? item (caar table)) (car table) (assq item (cdr table)))))
  140. (define (assv item table)
  141.   (if (null? table) #f
  142.       (if (eqv? item (caar table)) (car table) (assv item (cdr table)))))
  143. (define (assoc item table)
  144.   (if (null? table) #f
  145.       (if (equal? item (caar table)) (car table) (assoc item (cdr table)))))
  146.  
  147. (define (filter pred lst)
  148.   ; return a list of the items in lst satisfying pred
  149.   (define (filter-iter lst res)
  150.     (cond ((null? lst) res)
  151.       ((pred (car lst)) (filter-iter (cdr lst) (cons (car lst) res)))
  152.       (else (filter-iter (cdr lst) res))))
  153.   (reverse (filter-iter lst '())))
  154.  
  155. (define (equal? a b)
  156.   ; #t if the elements of a and b are recursively equal?
  157.   (or (eqv? a b)
  158.       (and (pair? a) (pair? b)
  159.        (equal? (car a) (car b))
  160.        (equal? (cdr a) (cdr b)))
  161.       (and (vector? a) (vector? b)
  162.        (equal? (vector->list a) (vector->list b)))
  163.       (and (box? a) (box? b)
  164.        (equal? (unbox a) (unbox b)))))
  165.  
  166. (define min
  167.   ; return the minimum of a list of numbers
  168.   (letrec ((min2 (lambda (a b) (if (< a b) a b))))
  169.     (lambda (first . rest) (reduce min2 rest first))))
  170.  
  171. (define max
  172.   ; return the maximum of a list of numbers
  173.   (letrec ((max2 (lambda (a b) (if (> a b) a b))))
  174.     (lambda (first . rest) (reduce max2 rest first))))
  175.  
  176. (define (newline . file)
  177.   (write-char #\newline (if (null? file) *stdout* (car file))))
  178.  
  179. (define string=? eqv?)
  180. (define char=? =)
  181. (define char<? <)
  182. (define char>? >)
  183. (define char<=? <=)
  184. (define char>=? >=)
  185.  
  186. ;;; ports
  187. ;;; note:  input and output ports are not separate types
  188. (define (open-input-file file) (file-open file "r"))
  189. (define (open-output-file file) (file-open file "w"))
  190. (define close-input-port file-close)
  191. (define close-output-port file-close)
  192. (define (current-input-port) *stdin*)
  193. (define (current-output-port) *stdout*)
  194. (define (input-port? file) (eq? (object-type file) 'file))
  195. (define output-port? input-port?)
  196. (define (call-with-input-file filename proc)
  197.   (let ((file (open-input-file filename)))
  198.     (begin1 (proc file) (close-input-port file))))
  199. (define (call-with-output-file filename proc)
  200.   (let ((file (open-output-file filename)))
  201.     (begin1 (proc file) (close-output-port file))))
  202.  
  203.  
  204. ;;; tracing functions
  205. ;;; note:  tail recursive calls do not have traceable exits
  206. (define (trace proc) (trace-entry (trace-exit proc)))
  207. (define (untrace proc) (untrace-entry (untrace-exit proc)))
  208. (define (trace-all . procs) (for-each trace procs))
  209. (define (untrace-all . procs) (for-each untrace procs))
  210.